PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/qksort.com/QKSORT.PAS

Pascal/Delphi Source File | 1990-03-01 | 5.4 KB | 172 lines

{$A-,B-,D+,E-,F-,I+,L+,N-,O-,R-,S+,V-}

unit qksort;

{
------------------------------------------------------------------------
QKSORT.PAS  -  Quicksort and binary search routines

Author:        Robert J. Showalter
CompuServe ID: 72220,466

Revised 05/09/89 to correct problem with sort algorithm.

Compile with Turbo Pascal v5.0 or higher.

Description of interface:

   procedure qsort(var b; nr,r : integer; f : fcmp_type);

      b             = memory array being sorted.  may be of any type.
      nr            = number of records (elements) in array (<=maxint)
      r             = record length, in bytes
      f             = user-written comparison function.  this function
                      is passed pointers to two records, p1 and p2.
                      it should compare the two records and return an
                      integer based on their rank in the desired
                      sort order:
                         <0 : record p1 should come BEFORE record p2
                          0 : the two records are equal in rank
                         >0 : record p1 should come AFTER record p2

   function bsearch(var key,var b; nr,r : integer; f : fcmp_type) : integer;

      key           = key value being searched for.  may be of any type.
      b             = memory array being sorted.  may be of any type.
      nr            = number of records (elements) in array (<=maxint)
      r             = record length, in bytes
      f             = user-written comparison function.  this function
                      is passed a record pointers, p1, and a pointer to
                      the key, p2.  it should compare the two record
                      with the key value and return an integer based
                      on the comparison:
                      sort order:
                         <0 : record p1 comes BEFORE the key value, p2.
                          0 : record p1 matches the key value, p2.
                         >0 : record p1 should come AFTER the key value, p2.

      If the key value was found, bsearch returns the RECORD NUMBER of the
      matching record (in the range 0..nr-1).  If the key value was not
      found, bsearch returns -1.
------------------------------------------------------------------------
}

interface

type
   fcmp_type        = function(var p1,p2) : integer;

procedure qsort(var b; nr,r : integer; f : fcmp_type);
function bsearch(var key,b; nr,r : integer; f : fcmp_type) : integer;


implementation

type
   buf_type         = array[0..0] of byte;

var
   buffer           : ^buf_type;
   fcmp             : fcmp_type;        { pointer to compare function }
   reclen           : word;             { record length }

{----------------------------------------------------------------------}

procedure swapbytes(var a,b; len : word);

begin
   inline(
      $1E/          { push ds           ; save DS reg }
      $8B/$8E/len/  { mov cx,[bp+4]     ; CX = len }
      $C5/$B6/a/    { lds si,[bp+10]    ; DS:SI = var a }
      $C4/$BE/b/    { les di,[bp+6]     ; ES:DI = var b }
      $FC/          { cld               ; set forward direction }
      $8A/$04/      { mov al,[SI]       ; get a }
      $8A/$25/      { mov ah,[DI]       ; get b }
      $88/$24/      { mov [SI],ah       ; store a }
      $AA/          { stosb             ; store b }
      $46/          { inc si            ; increment }
      $E2/$F6/      { loop ...          ; continue }
      $1F           { pop ds            ; restore DS reg }
   );
end;

{----------------------------------------------------------------------}

{ QuickSort algorithm }

procedure sort(l,r: integer);

var
   i,j,x             : word;
   pivot             : ^buf_type;       { "pivot" value }

begin
   i := l;
   j := r;
   x := (l + r) div 2;
   getmem(pivot,reclen);                { allocate pivot buffer }
   move(buffer^[x*reclen],pivot^,reclen);  { get pivot value }
   repeat
      while fcmp(buffer^[i*reclen],pivot^) < 0 do inc(i);
      while fcmp(pivot^,buffer^[j*reclen]) < 0 do dec(j);
      if integer(i) <= integer(j) then begin
         swapbytes(buffer^[i*reclen],buffer^[j*reclen],reclen);
         inc(i);
         dec(j);
      end;
   until integer(i) > integer(j);
   freemem(pivot,reclen);               { deallocate pivot buffer }
   if integer(l) < integer(j) then sort(l,j);
   if integer(i) < integer(r) then sort(i,r);
end;

{----------------------------------------------------------------------}

procedure qsort;

begin
   buffer := @b;
   reclen := r;
   fcmp := f;
   sort(0,pred(nr));
end;

{----------------------------------------------------------------------}

function bsearch;

var
   l,u,i,j          : integer;
   done             : boolean;

begin
   buffer := @b;
   l := 0;
   u := nr;
   done := false;
   while not done do begin
      i := (l+u) div 2;                 { compute midpoint of range }
      j := f(buffer^[i * r],key);
      if j=0 then begin
         bsearch := i;
         done := true;
      end else if j<0 then begin
         if l=i then begin
            bsearch := -1;
            done := true;
         end else
            l := i;
      end else begin
         if u=i then begin
            bsearch := -1;
            done := true;
         end else
            u := i;
      end;
   end;
end;


end.